﻿Imports System
Imports System.Collections.Generic
Imports System.Text
Imports System.DirectoryServices
Imports System.Security.Principal
Imports System.Runtime.InteropServices
Imports System.Security.Cryptography
Imports System.IO
Imports System.Text.RegularExpressions

Public Class ADHelper
    Private mobjCryptoService As SymmetricAlgorithm = New RijndaelManaged()
    Private Key As String = "Guz(%&hj7x89H$yuBI0456FtmaT5&fvHUFCy76*h%(HilJ$lhj!y6&(*jkP87jH7"
    <ComImport()> _
    <Guid("9068270B-0939-11D1-8BE1-00C04FD8D503")> _
    <InterfaceType(ComInterfaceType.InterfaceIsDual)> _
    Friend Interface IADsLargeInteger
        <DispId(2)> _
        Property HighPart() As Integer
        <DispId(3)> _
        Property LowPart() As Integer
    End Interface
    Public Function CheckUser(ByVal strDomainName As String, ByVal strManageAccount As String, ByVal strManagePassWord As String, ByVal strUserName As String, ByVal intWarningDays As Integer) As String
        Dim strPath As String = "LDAP://" + strDomainName
        Dim strInfo As String = ""
        If strDomainName = "." Then
            Return strInfo
        End If
        Dim adminEntity As New DirectoryEntry(strPath, strManageAccount, strManagePassWord)
        Dim maxPwdAge As New TimeSpan(0, 0, 0, 0)
        Try
            Dim maxPwdAgeData As IADsLargeInteger = TryCast(adminEntity.Properties("maxPwdAge").Value, IADsLargeInteger)
            If maxPwdAgeData Is Nothing Then
                strInfo = ""
                Return strInfo
            End If
            maxPwdAge = TimeSpan.FromTicks(Math.Abs(maxPwdAgeData.HighPart * 4294967296) + maxPwdAgeData.LowPart)
        Catch myError As Exception
            If myError.InnerException IsNot Nothing Then
                strInfo = "管理账户失效。" + myError.Message + " " + myError.InnerException.Message
            Else
                strInfo = "管理账户失效。" + myError.Message
            End If
            Return strInfo
        End Try
        Try
            Dim deSearch As New DirectorySearcher(adminEntity)
            deSearch.Filter = "(&(&(objectCategory=person)(objectClass=user))(cn=" + strUserName + "))"
            deSearch.SearchScope = SearchScope.Subtree
            Dim result1 As SearchResult = deSearch.FindOne()
            If result1 Is Nothing Then
                strInfo = " "
                Return strInfo
            End If
            adminEntity.Close()
            Dim entity As New DirectoryEntry(result1.Path)
            ' 搜索账户
            Dim searcher As New DirectorySearcher(entity, "(&(!(pwdLastSet=0))(objectCategory=user))", New String() {"pwdLastSet", "sAMAccountName", "displayName"}, SearchScope.Subtree)
            Dim results As SearchResultCollection = searcher.FindAll()
            entity.Close()
            If results.Count = 0 Then
                strInfo = " "
                '没有设置，正常登录
                Return strInfo
            Else
                For Each result As SearchResult In results
                    Dim userEntry As DirectoryEntry = result.GetDirectoryEntry()
                    If userEntry.Properties("pwdLastSet").Value Is Nothing Then
                        Continue For
                    End If
                    '获取密码到期日 
                    Dim pwdExpireDate As DateTime = DateTime.FromFileTime(((DirectCast(userEntry.Properties("pwdLastSet").Value, IADsLargeInteger)).HighPart * 4294967296) + (DirectCast(userEntry.Properties("pwdLastSet").Value, IADsLargeInteger)).LowPart)
                    Dim pwdExpireDateTmp As DateTime = pwdExpireDate.Add(maxPwdAge)
                    Dim tmsTmp As TimeSpan = pwdExpireDateTmp - DateTime.Now
                    If tmsTmp.Days <= 0 AndAlso tmsTmp.Hours <= 0 AndAlso tmsTmp.Minutes <= 0 Then
                        strInfo = "账户密码已经到期！请修改密码"
                        Exit For
                    Else
                        If tmsTmp.Days <= intWarningDays Then
                            '提醒期比较
                            strInfo = String.Format("账户密码还差 {0} 天{1}小时{2}分钟到期，请注意修改密码", tmsTmp.Days, tmsTmp.Hours, tmsTmp.Minutes)
                            Exit For
                        Else
                            strInfo = " "
                            Exit For
                        End If
                    End If
                Next
                Return strInfo
            End If
        Catch myError As Exception
            '用户账户异常
            If myError.InnerException IsNot Nothing Then
                strInfo = myError.Message + " " + myError.InnerException.Message
            Else
                strInfo = myError.Message
            End If
            Return strInfo
        End Try
    End Function
#Region "检查用户密码是否正确"
    Public Function CheckUserPassWord(ByVal strDomainName As String, ByVal strUserName As String, ByVal strPassWord As String, ByRef strInfo As String) As Boolean
        Try
            Dim strPath As String = "LDAP://" + strDomainName
            Dim de As New DirectoryEntry(strPath, strUserName, strPassWord, AuthenticationTypes.Secure)
            Dim deSearch As New DirectorySearcher(de)
            deSearch.Filter = "(&(&(objectCategory=person)(objectClass=user))(sAMAccountName=" + strUserName + "))"
            deSearch.SearchScope = SearchScope.Subtree

            Dim result As SearchResult = deSearch.FindOne()
            de = New DirectoryEntry(result.Path)
            strInfo = ""
            Return True
        Catch myError As Exception
            If myError.InnerException IsNot Nothing Then
                strInfo = myError.Message + " " + myError.InnerException.Message
            Else
                strInfo = myError.Message
            End If
            Return False
        End Try
    End Function
#End Region
#Region "检查管理账户是否有效"
    Private Function CheckManageAccount(ByVal adminEntity As DirectoryEntry, ByVal strManageAccount As String) As String
        Try
            Dim adminSearch As New DirectorySearcher(adminEntity)
            adminSearch.Filter = "(&(&(objectCategory=person)(objectClass=user))(sAMAccountName=" + strManageAccount + "))"
            adminSearch.SearchScope = SearchScope.Subtree
            Dim AdminResult As SearchResult = adminSearch.FindOne()
            Dim deTmp As New DirectoryEntry(AdminResult.Path)
            deTmp.Close()
            Return " "
        Catch myError As Exception
            If myError.InnerException IsNot Nothing Then
                Return "管理账户失效。" + myError.Message + " " + myError.InnerException.Message
            Else
                Return "管理账户失效。" + myError.Message
            End If
        End Try
    End Function
    Public Function CheckManageAccount(ByVal strDomainName As String, ByVal strManageAccount As String, ByVal strManagePassWord As String) As String
        Try
            Dim strPath As String = "LDAP://" + strDomainName
            Dim adminEntity As New DirectoryEntry(strPath, strManageAccount, strManagePassWord)
            Dim adminSearch As New DirectorySearcher(adminEntity)
            adminSearch.Filter = "(&(&(objectCategory=person)(objectClass=user))(sAMAccountName=" + strManageAccount + "))"
            adminSearch.SearchScope = SearchScope.Subtree
            Dim AdminResult As SearchResult = adminSearch.FindOne()
            Dim deTmp As New DirectoryEntry(AdminResult.Path)
            adminEntity.Close()
            deTmp.Close()
            Return " "
        Catch myError As Exception
            If myError.InnerException IsNot Nothing Then
                Return "管理账户失效。错误信息：" + myError.Message + " " + myError.InnerException.Message
            Else
                Return "管理账户失效。错误信息：" + myError.Message
            End If
        End Try
    End Function
#End Region
#Region "检查用户是否存在"
    Public Function CheckUserAccount(ByVal strDomainName As String, ByVal strManageAccount As String, ByVal strManagePassWord As String, ByVal userName As String) As Boolean
        Try
            Dim strPath As String = "LDAP://" + strDomainName
            Dim adminEntity As New DirectoryEntry(strPath, strManageAccount, strManagePassWord)
            Dim adminSearch As New DirectorySearcher(adminEntity)
            adminSearch.Filter = "(&(&(objectCategory=person)(objectClass=user))(sAMAccountName=" + userName + "))"
            adminSearch.SearchScope = SearchScope.Subtree
            Dim AdminResult As SearchResult = adminSearch.FindOne()
            Dim deTmp As New DirectoryEntry(AdminResult.Path)
            adminEntity.Close()
            deTmp.Close()
            Return True
        Catch myError As Exception
            Return False
        End Try
    End Function
#End Region
#Region "检查账号是否激活"
    Public Function AccountUserActive(ByVal strDomainName As String, ByVal commonName As String, ByVal strManageAccount As String, ByVal strManagePassWord As String, ByRef isNormal As Boolean) As String
        Try
            Dim strPath As String = "LDAP://" + strDomainName
            Dim adminEntity As New DirectoryEntry(strPath, strManageAccount, strManagePassWord)
            Dim strInfo As String = CheckManageAccount(adminEntity, strManageAccount)
            If strInfo.Trim() <> "" Then
                Return strInfo
            End If
            Dim deSearch As New DirectorySearcher(adminEntity)
            deSearch.Filter = "(&(&(objectCategory=person)(objectClass=user))(cn=" + commonName + "))"
            deSearch.SearchScope = SearchScope.Subtree

            Dim result As SearchResult = deSearch.FindOne()
            Dim de As New DirectoryEntry(result.Path)
            Dim userAccountControl As Integer = Convert.ToInt32(de.Properties("userAccountControl")(0))
            de.Close()
            Dim isActive As Boolean = IsAccountActive(userAccountControl)
            If isActive = True Then
                isNormal = True
                Return "用户域账号正常"
            Else
                isNormal = False
                Return "用户域账号被锁定，不能正常使用"
            End If
        Catch myError As Exception
            isNormal = False
            Return "用户账号异常：" + myError.Message + myError.InnerException.Message
        End Try
    End Function
    Private Function IsAccountActive(ByVal userAccountControl As Integer) As Boolean
        Dim userAccountControl_Disabled As Integer = Convert.ToInt32(2)
        Dim flagExists As Integer = userAccountControl And userAccountControl_Disabled
        If flagExists > 0 Then
            Return False
        Else
            Return True
        End If
    End Function
#End Region
#Region "重置密码"
    Public Function SetPasswordByAccount(ByVal sAMAccountName As String, ByVal newPassword As String, ByVal DomainName As String, ByVal ADUser As String, ByVal ADPassword As String) As Boolean
        Try
            SetPasswordByAccount = False
            Dim de As DirectoryEntry = GetDirectoryEntryByAccount(sAMAccountName, DomainName, ADUser, ADPassword)
            Dim impersonate As New IdentityImpersonation(ADUser, ADPassword, DomainName)
            impersonate.BeginImpersonate()
            de.Invoke("SetPassword", New Object() {newPassword})
            impersonate.StopImpersonate()
            de.Close()
            SetPasswordByAccount = True

        Catch ex As Exception
            Throw ex
        End Try
    End Function
    Private Function GetDirectoryObject(ByVal DomainName As String, ByVal ADUser As String, ByVal ADPassword As String) As DirectoryEntry
        Dim strPath As String = "LDAP://" + DomainName
        Dim entry As New DirectoryEntry(strPath, ADUser, ADPassword, AuthenticationTypes.Secure)
        Return entry
    End Function
    Private Function GetDirectoryEntryByAccount(ByVal sAMAccountName As String, ByVal DomainName As String, ByVal ADUser As String, ByVal ADPassword As String) As DirectoryEntry
        Dim de As DirectoryEntry = GetDirectoryObject(DomainName, ADUser, ADPassword)
        Dim deSearch As New DirectorySearcher(de)
        deSearch.Filter = "(&(&(objectCategory=person)(objectClass=user))(sAMAccountName=" + sAMAccountName + "))"
        deSearch.SearchScope = SearchScope.Subtree
        Try
            Dim result As SearchResult = deSearch.FindOne()
            Dim de1 As New DirectoryEntry(result.Path)
            de.Close()
            Return de1
        Catch ex As Exception
            de.Close()
            Throw ex
        End Try
    End Function
#End Region
#Region "加密解密方法"
    ''' <summary>
    ''' 加密方法
    ''' </summary>
    ''' <param name="Source">待加密的串</param>
    ''' <returns>经过加密的串</returns>
    Public Function Encrypto(ByVal Source As String) As String
        Dim bytIn As Byte() = UTF8Encoding.UTF8.GetBytes(Source)
        Dim ms As New MemoryStream()
        mobjCryptoService.Key = GetLegalKey()
        mobjCryptoService.IV = GetLegalIV()
        Dim oEncrypto As ICryptoTransform = mobjCryptoService.CreateEncryptor()
        Dim cs As New CryptoStream(ms, oEncrypto, CryptoStreamMode.Write)
        cs.Write(bytIn, 0, bytIn.Length)
        cs.FlushFinalBlock()
        ms.Close()
        Dim bytOut As Byte() = ms.ToArray()
        Return Convert.ToBase64String(bytOut)
    End Function
    ''' <summary>
    ''' 解密方法
    ''' </summary>
    ''' <param name="Source">待解密的串</param>
    ''' <returns>经过解密的串</returns>
    Public Function Decrypto(ByVal Source As String) As String
        Try
            Dim bytIn As Byte() = Convert.FromBase64String(Source)
            Dim ms As New MemoryStream(bytIn, 0, bytIn.Length)
            mobjCryptoService.Key = GetLegalKey()
            mobjCryptoService.IV = GetLegalIV()
            Dim encrypto As ICryptoTransform = mobjCryptoService.CreateDecryptor()
            Dim cs As New CryptoStream(ms, encrypto, CryptoStreamMode.Read)
            Dim sr As New StreamReader(cs)
            Return sr.ReadToEnd()
        Catch ex As Exception
            Throw ex
        End Try
    End Function
    ''' <summary>
    ''' 获得密钥
    ''' </summary>
    ''' <returns>密钥</returns>
    Private Function GetLegalKey() As Byte()
        Dim sTemp As String = Key
        mobjCryptoService.GenerateKey()
        Dim bytTemp As Byte() = mobjCryptoService.Key
        Dim KeyLength As Integer = bytTemp.Length
        If sTemp.Length > KeyLength Then
            sTemp = sTemp.Substring(0, KeyLength)
        ElseIf sTemp.Length < KeyLength Then
            sTemp = sTemp.PadRight(KeyLength, " "c)
        End If
        Return ASCIIEncoding.ASCII.GetBytes(sTemp)
    End Function
    ''' <summary>
    ''' 获得初始向量IV
    ''' </summary>
    ''' <returns>初试向量IV</returns>
    Private Function GetLegalIV() As Byte()
        Dim sTemp As String = "E4ghj*Ghg7!rNIfb&95GUY86GfghUb#er57HBh(u%g6HJ($jhWk7&!hg4ui%$hjk"
        mobjCryptoService.GenerateIV()
        Dim bytTemp As Byte() = mobjCryptoService.IV
        Dim IVLength As Integer = bytTemp.Length
        If sTemp.Length > IVLength Then
            sTemp = sTemp.Substring(0, IVLength)
        ElseIf sTemp.Length < IVLength Then
            sTemp = sTemp.PadRight(IVLength, " "c)
        End If
        Return ASCIIEncoding.ASCII.GetBytes(sTemp)
    End Function
#End Region
#Region "创建用户"
    Public Function CreateNewUser(ByVal ldapDN As String, ByVal commonName As String, ByVal sAMAccountName As String, ByVal password As String, ByVal ADUser As String, ByVal ADPassword As String, _
     ByVal DomainName As String) As DirectoryEntry
        Dim strPath As String = "LDAP://" + DomainName
        Dim entry As New DirectoryEntry(strPath, ADUser, ADPassword, AuthenticationTypes.Secure)
        Dim subEntry As DirectoryEntry = entry.Children.Find(ldapDN)
        Dim deUser As DirectoryEntry = subEntry.Children.Add("CN=" + commonName, "user")
        deUser.Properties("sAMAccountName").Value = sAMAccountName
        deUser.Properties("userPrincipalName").Value = sAMAccountName + "@" + DomainName
        deUser.Properties("name").Value = sAMAccountName
        deUser.Properties("displayName").Value = sAMAccountName
        deUser.Properties("description").Value = DateTime.Now.ToString().Trim() + " Camstar系统创建"
        deUser.CommitChanges()
        SetPasswordByAccount(sAMAccountName, password, DomainName, ADUser, ADPassword)
        EnableUser(commonName, DomainName, ADUser, ADPassword)
        deUser.Close()
        Return deUser
    End Function
    Private Sub EnableUser(ByVal commonName As String, ByVal DomainName As String, ByVal ADUser As String, ByVal ADPassword As String)
        Dim de As DirectoryEntry = GetDirectoryEntry(commonName, DomainName, ADUser, ADPassword)
        EnableUser(de, ADUser, ADPassword, DomainName)
    End Sub
    Private Sub EnableUser(ByVal de As DirectoryEntry, ByVal ADUser As String, ByVal ADPassword As String, ByVal DomainName As String)
        Dim impersonate As New IdentityImpersonation(ADUser, ADPassword, DomainName)
        impersonate.BeginImpersonate()
        de.Properties("userAccountControl")(0) = 512
        '| 0X10000;
        de.CommitChanges()
        impersonate.StopImpersonate()
        de.Close()
    End Sub
    Private Function GetDirectoryEntry(ByVal commonName As String, ByVal DomainName As String, ByVal ADUser As String, ByVal ADPassword As String) As DirectoryEntry
        Dim de As DirectoryEntry = GetDirectoryObject(DomainName, ADUser, ADPassword)
        Dim deSearch As New DirectorySearcher(de)
        deSearch.Filter = "(&(&(objectCategory=person)(objectClass=user))(cn=" + commonName + "))"
        deSearch.SearchScope = SearchScope.Subtree
        Try
            Dim result As SearchResult = deSearch.FindOne()
            de = New DirectoryEntry(result.Path)
            Return de
        Catch
            Return Nothing
        End Try
    End Function
#End Region
    Public Function CheckPassWordRule(ByVal strPassWord As String) As Boolean
        Dim r As New Regex("[a-zA-Z]")
        '字母
        Dim m As New Regex("\d+")
        '数字
        Dim n As New Regex("[-`=\\\[\];',./~!@#$%^&*()_+|{}:""<>?]")
        '特殊字符
        Dim isOK1 As Boolean = r.IsMatch(strPassWord)
        Dim isOK2 As Boolean = m.IsMatch(strPassWord)
        Dim isOK3 As Boolean = n.IsMatch(strPassWord)
        If isOK1 = True AndAlso isOK2 = True AndAlso isOK3 = True Then
            Return True
        Else
            Return False
        End If
    End Function
    Public Class IdentityImpersonation
        <DllImport("advapi32.dll", SetLastError:=True)> _
        Public Shared Function LogonUser(ByVal lpszUsername As String, ByVal lpszDomain As String, ByVal lpszPassword As String, ByVal dwLogonType As Integer, ByVal dwLogonProvider As Integer, ByRef phToken As IntPtr) As Boolean
        End Function
        <DllImport("advapi32.dll", CharSet:=CharSet.Auto, SetLastError:=True)> _
        Public Shared Function DuplicateToken(ByVal ExistingTokenHandle As IntPtr, ByVal SECURITY_IMPERSONATION_LEVEL As Integer, ByRef DuplicateTokenHandle As IntPtr) As Boolean
        End Function
        <DllImport("kernel32.dll", CharSet:=CharSet.Auto)> _
        Public Shared Function CloseHandle(ByVal handle As IntPtr) As Boolean
        End Function
        ' 要模拟的用户的用户名、密码、域(机器名)  
        Private _sImperUsername As String
        Private _sImperPassword As String
        Private _sImperDomain As String
        ' 记录模拟上下文  
        Private _imperContext As WindowsImpersonationContext
        Private _adminToken As IntPtr
        Private _dupeToken As IntPtr
        ' 是否已停止模拟  
        Private _bClosed As Boolean
        '''  
        '''构造函数  
        '''  
        ''' 所要模拟的用户的用户名  
        ''' 所要模拟的用户的密码  
        ''' 所要模拟的用户所在的域  
        Public Sub New(ByVal impersonationUsername As String, ByVal impersonationPassword As String, ByVal impersonationDomain As String)
            _sImperUsername = impersonationUsername
            _sImperPassword = impersonationPassword
            _sImperDomain = impersonationDomain
            _adminToken = IntPtr.Zero
            _dupeToken = IntPtr.Zero
            _bClosed = True
        End Sub
        Protected Overrides Sub Finalize()
            Try
                '''  
                '''析构函数  
                '''  
                If Not _bClosed Then
                    StopImpersonate()
                End If
            Finally
                MyBase.Finalize()
            End Try
        End Sub
        '''  
        '''开始身份角色模拟。  
        '''  
        '''  
        Public Function BeginImpersonate() As Boolean
            Dim bLogined As Boolean = LogonUser(_sImperUsername, _sImperDomain, _sImperPassword, 2, 0, _adminToken)
            If Not bLogined Then
                Return False
            End If
            Dim bDuped As Boolean = DuplicateToken(_adminToken, 2, _dupeToken)
            If Not bDuped Then
                Return False
            End If
            Dim fakeId As New WindowsIdentity(_dupeToken)
            _imperContext = fakeId.Impersonate()
            _bClosed = False
            Return True
        End Function
        '''  
        '''停止身分角色模拟。  
        '''  
        Public Sub StopImpersonate()
            _imperContext.Undo()
            CloseHandle(_dupeToken)
            CloseHandle(_adminToken)
            _bClosed = True
        End Sub
    End Class
End Class
